home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
PASCAL
/
0187.ZIP
/
SNAKEPC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-02-07
|
10KB
|
373 lines
Program Snake;
{
This insidious game of greed was adapted for Turbo Pascal Bruce
McKinney. It's source is a collection of game programs for Apple
Pascal. It's written for the IBM PC and compatibles, but you can
easily adapt it for other computers by changing the constants.
The border characters (NW thru EW) can be replaced if I's and
dashes if you don't have access to the upper 128 graphics
characters used on the IBM. Same with the player characters.
If you don't have a numeric keypad, replace the command characters
with any diamond of characters. For example, E,S,D,X. Procedure
NumsOn and NumsOff are for the IBM. Delete them if you don't have
an IBM or similar computer. }
Const
PlayerChar = #2;
SnakeChar = #4;
MoneyChar = #15;
DoorChar = #219;
NW = #201;
NE = #187;
SW = #200;
SE = #188;
NS = #186;
EW = #205;
Quit = 'q';
UpCommand = '8';
DownCommand = '2';
LeftCommand = '4';
RightCommand = '6';
SnakeLength = 5;
Height = 24;
Width = 80;
ClearScreen = 12;
MoneyWorth = 25;
Type
Coordinate = record
X : Integer;
Y : Integer;
end;
SnakeType = Array[1..SnakeLength] of Coordinate;
Thing = (PlayerThing,SnakeThing,MoneyThing,DoorThing,EmptyThing,ScoreThing);
Var
Snake : SnakeType;
Player, Money, Door : Coordinate;
Score, TopScore : Integer;
Left, Eaten, DoneRead, PlayAgain : Boolean;
Screen : Array[1..Width] of Array[1..Height] of Thing;
LooksLike : Array[Thing] of Char;
ch : char;
ScoreFile : File of integer;
Label 1;
{$U+}
Procedure NumsOn;
begin
mem[0:1047] := mem[0:1047] or 32;
end;
Procedure NumsOff;
begin
mem[0:1047] := mem[0:1047] and 223;
end;
Procedure ReadScore;
begin
Assign(ScoreFile,'Snakscor.dta');
{$I-}Reset(ScoreFile) {$I+};
if (IOresult <> 0) then TopScore := 1
else Read(ScoreFile,TopScore);
Close(ScoreFile)
end;
Procedure SaveScore;
begin
Assign(ScoreFile,'Snakscor.dta');
ReWrite(ScoreFile);
Write(ScoreFile,TopScore);
Close(ScoreFile)
end;
Procedure Border;
Var
Col : Integer;
Row : Integer;
begin
gotoxy(1,1);write(nw);
for Col := 2 to (width-1) do write(ew);write(ne);
for Row := 2 to (Height-1) do
begin
gotoxy(1,row);write(ns);
for Col := 2 to (width-1) do write(' ');write(ns);
end;
gotoxy(1,height);write(sw);
for Col := 2 to (width-1) do write(ew);write(se);
end;
Procedure Instruction;
Var
Answer : Char;
begin
ReadScore;
writeln('You are about to enter the mysterious land of the Serpent');
writeln('of Kalajan. But before you go in, consider these choices: ');
writeln;
writeln('1. I''d like to meet this reptile before my adventure.');
writeln('2. I already know the serpent. Just let me in.');
writeln('3. Reset the treasure level to the minimum amount.');
writeln;
write('So? What''s it going to be? ');
Repeat
Read(Kbd,Answer);
Until Answer in ['1','2','3'];
if Answer = '3' then
begin
TopScore := 101;
SaveScore;
Writeln;writeln;
DoneRead := True;
Write('Now choose from the first two options above:');
Repeat
Read(Kbd,Answer);
Until Answer in ['1','2'];
end;
if Answer = '1' then
begin
ClrScr;
writeln(' Welcome to the Forest of Kalajan. Please don''t be');
writeln('frightened by my hideous appearance. Within the fearsome');
writeln('body of a serpent rests a peaceful and generous spirit.');
writeln('If you are master of your own passions, you will have a');
writeln('pleasant and profitable stay in this paradise. ');
writeln(' However, the forest is not without dangers. Soon you''ll');
writeln('see a glittering gold coin. There are many of them here.');
writeln('They look like this ',MoneyChar,'. You may take as many as you like');
writeln('as souvenirs. But I must warn you that greed for these coins');
writeln('has been the downfall of many of your predecessors. You see,');
writeln('despite my gentle nature, a display of avarice drives me ');
writeln('into a blind, uncontrollable rage.');
writeln(' I''m sorry to say that during these fits I''ve sometimes');
writeln('devoured my guests. As a matter of fact no one has ever ');
writeln('left here alive with more than $',TopScore-1,' worth of treasure.');
writeln('So take a reasonable amount. Don''t be greedy. There''s a ');
writeln('door that looks like this █ through which you can leave ');
writeln('when you''re ready.');
writeln(' So enjoy your stay. Use the arrow keys to move through');
writeln('the wood and view its beauty at your leisure. Press any key');
writeln('when you''re ready to enter the wondrous Forest of Kalajan.');
repeat
read(Kbd,Answer)
Until Answer <> '';
end;
end; {Instructions}
Procedure Initialize;
Var
X,Y : Integer;
begin {Initialize}
ClrScr;
Border;
For X := 2 to Width-1 do
For Y := 2 to Height-1 do
Screen[X,Y] := EmptyThing;
Randomize;
LooksLike[SnakeThing] := SnakeChar;
LooksLike[PlayerThing] := PlayerChar;
LooksLike[MoneyThing] := MoneyChar;
LooksLike[EmptyThing] := ' ';
LooksLike[DoorThing] := DoorChar;
Left := False;
Eaten := False;
Score := 1;
gotoxy(1,25);write('Your treasure is $',Score - 1,'.');
gotoxy(45,25);Write('No one has ever got more than $',TopScore - 1,'!');
end; {Initialize}
Function FreeSpot(Pos : Coordinate) : Boolean;
begin
If (Pos.x in [2..Width-1]) and (Pos.Y in [2..Height-1]) then
FreeSpot := Screen[Pos.X,Pos.Y] = EmptyThing
else
FreeSpot := False
end; {FreeSpot}
Procedure MakeSpace(var NewPos : Coordinate; ForWhat : Thing);
begin
With NewPos do
begin
Repeat
X := Random(Width-2)+2;
Y := Random(Height-2)+2;
Until FreeSpot(NewPos);
Gotoxy(X,Y);
Write(LooksLike[ForWhat]);
Screen[X,Y] := ForWhat
end
end; {MakeSpace}
Procedure PlaceNearby(Var Near, Coord : Coordinate);
var
DeltaX, DeltaY : Integer;
begin {PlaceNearby}
Repeat
Repeat
DeltaX := Random(3)-1;
DeltaY := Random(3)-1;
Until (DeltaX <> 0) or (DeltaY <> 0);
Near.X := Coord.X + DeltaX;
Near.Y := Coord.Y + DeltaY;
Until (FreeSpot(Near) or ((Near.x = Player.x) and (Near.y = Player.y)));
GotoXY(Near.X,Near.Y);
Screen[Near.X,Near.Y] := SnakeThing;
Write(LooksLike[SnakeThing])
end; {PlaceNearby}
Procedure Remove(Pos : Coordinate);
begin
GotoXY(Pos.X,Pos.Y);
Write(' ');
Screen[Pos.X,Pos.Y] := EmptyThing
end; {Remove}
Procedure PlaceObjects;
var
SnakeBody : Integer;
begin {PlaceObjects}
MakeSpace(Snake[1],SnakeThing);
For SnakeBody := 2 to SnakeLength do
PlaceNearby(Snake[SnakeBody],Snake[SnakeBody-1]);
MakeSpace(Money,MoneyThing);
MakeSpace(Door,DoorThing);
MakeSpace(Player,PlayerThing);
gotoxy(player.x,player.y);
end; {PlaceObjects}
Procedure TakeGold;
begin
Score := Score + MoneyWorth;
GotoXY(19,25);
Write(Score-1);
Screen[Money.X,Money.Y] := EmptyThing;
MakeSpace(Money,MoneyThing)
end; {TakeGold}
Procedure PlayerMove;
Var
Command : Char;
OldPos : Coordinate;
begin
OldPos := Player;
Repeat
Read(Kbd,Command);
until Command in [UpCommand,DownCommand,LeftCommand,RightCommand,quit];
if Command = quit then begin ClrScr;NumsOff;halt end;
With Player do
begin
Case Command of
UpCommand : If Y > 2 then Y := Y - 1;
DownCommand : If Y < Height-1 then Y := Y + 1;
LeftCommand : If X > 2 then X := X - 1;
RightCommand : If X < Width-1 then X := X + 1;
end; {Case}
If Screen[X,Y] = ScoreThing then Player := OldPos
else
begin
Remove(OldPos);
If ((Player.x = Money.x) and (player.y = money.y)) then TakeGold {*}
else if ((Player.x = Door.x) and (Player.y = Door.y)) then Left := True;
GotoXY(X,Y);
Write(PlayerChar);
Screen[X,Y] := PlayerThing
end
end
end; {PlayerMove}
Function Sign(X : Integer) : Integer;
begin
If X = 0 then Sign := 0
else if X > 0 then Sign := 1
else Sign := -1
end; {Sign}
Procedure SnakeMove;
Var
NewPos : Coordinate;
BodyPart : Integer;
begin {PlayerMove}
If Random(Score+1) <= 100 then PlaceNearby(NewPos,Snake[1])
else
begin
NewPos.X := Snake[1].X + Sign(Player.X - Snake[1].X);
NewPos.y := Snake[1].Y + Sign(Player.Y - Snake[1].Y);
If (Screen[NewPos.X, NewPos.Y] = EmptyThing) or
((NewPos.x = Player.x) and (NewPos.y = Player.Y)) then
begin
GotoXY(NewPos.X,NewPos.Y);
Write(SnakeChar);
Screen[NewPos.X,NewPos.Y] := SnakeThing;
end
else
PlaceNearby(NewPos,Snake[1]);
end;
Remove(Snake[SnakeLength]);
If ((NewPos.x = Player.x) and (NewPos.y = Player.y)) then Eaten := True;
For BodyPart := SnakeLength Downto 2 do
begin
Snake[BodyPart] := Snake[BodyPart - 1];
If ((Snake[BodyPart].x = Player.x) and (Snake[BodyPart].y = Player.y))
then Eaten := True
end;
Snake[1] := NewPos;
gotoxy(Player.x,player.y)
end; {SnakeMove}
Procedure FinalScore;
begin
If Left then
begin
If TopScore < Score then
begin
TopScore := Score;
SaveScore;
end;
gotoXY(1,25);
write('You have escaped with $',score-1,'.');
end
else write('The snake has eaten you!');
gotoxy(30,25);write(' ');
gotoxy(30,25);write('Do you want to play again? ');
repeat
read(kbd,ch)
until ch in ['y','n'];
if ch = 'y' then PlayAgain := True else PlayAgain := False;
ClrScr;
end;
begin {Main}
NumsOn;
Instruction;
1 : Initialize;
PlaceObjects;
Repeat
PlayerMove;
If not Left then SnakeMove
Until Left or Eaten;
GotoXY(1,Height);
writeln;
FinalScore;
If PlayAgain then goto 1;
NumsOff;
end.
keMove
Until Left or Eaten;
GotoXY(1,Height);
writeln;